{******************************************************************}
{                                                                  }
{   Dr. Bob's Head Converter Combined Console/GUI Version          }
{ 			                                                           }
{ Copyright (C) 1997-2006 Bob Swart (A.K.A. Dr. Bob).          	   }
{                                                                  }
{ Contributor(s): Alan C. Moore (acmdoc@aol.com)                   }
{                 Marcel van Brakel  (brakelm@chello.nl)           }
{                 Michael Beck (mbeck1@zoomtown.com)               }
{                 Bob Cousins (bobcousins34@hotmail.com)           }
{                                                                  }
{                                                                  }
{ Obtained through:                                                }
{ Joint Endeavour of Delphi Innovators (Project JEDI)              }
{                                                                  }
{ You may retrieve the latest version of this file at the Project  }
{ JEDI home page, located at http://delphi-jedi.org                }
{ Maintained by the Project JEDI DARTH Team; To join or to report  }
{ bugs, contact Alan C. Moore at acmdoc@aol.com                    }
{                                                                  }
{ The contents of this file are used with permission, subject to   }
{ the Mozilla Public License Version 1.1 (the "License"); you may  }
{ not use this file except in compliance with the License. You may }
{ obtain a copy of the License at                                  }
{ http://www.mozilla.org/MPL/MPL-1.1.html                          }
{                                                                  }
{ Software distributed under the License is distributed on an      }
{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or }
{ implied. See the License for the specific language governing     }
{ rights and limitations under the License.                        }
{                                                                  }
{******************************************************************}



unit HeadPars;   { New Version Reorganized by Alan C. Moore; 11/11/2000 }
                 { Not producing converted output - B.Swart; 12/16/2000 }
{.$A+,B-,C-,D-,E-,F-,G-,H-,I-,L-,N-,O+,P-,Q-,R+,S+,T-,V-,X-}
interface

  function HeadConvert(const FileName: String; Explicit: Boolean): Word;
  {
    return: 0 = success
            1 = could not open the header file FileName.H
            2 = output file (FileName.pas) already exists
  }

implementation
uses
  HeadVars, HeadUtil, Forms, Dialogs, Messages, Controls, Windows,
  {$IFDEF MSDOS}
    DOS
  {$ELSE}
    SysUtils
  {$ENDIF};

{ Main Function -- Nesting Level 0 }
function HeadConvert(const FileName: String; Explicit: Boolean): Word;
var
  i,j,k: Integer;
{$IFDEF MSDOS}
var
  Year,Month,Day,DayOfWeek,
  Hour,Min,Sec,Sec100: Word;
{$ENDIF}
{!ACM My reorganization starts here}
{!ACM Start of nested functions}

  function SetupInitialFiles: boolean;  { Nesting Level One; first called }
  begin
    SetupInitialFiles := True;
    HeadConvert := 0;
    Str := FileName;
  {$IFDEF MSDOS}
    FSplit(FileName,Dir,DLL,Str);
    Str := FileName;
  {$ELSE}
    Dir := ExtractFilePath(Str);
    DLL := ExtractFileName(Str); { without .h extension }
  {$ENDIF}
    if (Pos('.',DLL) > 0) then DLL[0] :=AnsiChar( Chr(Pos('.',DLL)-1));
    Upper(DLL);
    System.Assign(header,Dir+DLL+'.h'); { only .h, no .H or .hpp }
    System.reset(header);
    if IOResult <> 0 then
    begin
      HeadConvert := 1;
      SetupInitialFiles := False;
      Exit { could not open header file Dir+DLL+.H }
    end;
  {$IFNDEF MSDOS}
    if FileExists(Dir+DLL+'.pas') then
{!ACM Jan 2001; Need to include file overwrite dialog here }
{!ACM Jan 2001; four lines added }
    if Application.MessageBox('Do you wish to overwrite the existing PAS file?',
       'Overwrite PAS file?', MB_YESNOCANCEL + MB_ICONQUESTION)<>mrYes then
    begin
      HeadConvert := 2;
      SetupInitialFiles := False;
      Exit { output file (Dir+Pas+.pas) already exists }
    end;
  {$ENDIF}
    Assign(output,Dir+DLL+'.~PA');
    rewrite(output);
  end; { SetupInitialFiles }

  procedure WriteTempFile;   { Nesting Level One; second called }
  begin
    writeln('unit ',DLL,';');
    writeln('{**************************************************************************}');
    writeln('{','}':75);
    writeln('{    This C DLL header file first (automatic) conversion generated by:     }');
    writeln('{    HeadConv 4.2 (c) 2000-2206 by Bob Swart (aka Dr.Bob - www.drbob42.com)}');
    writeln('{    Second (refactored) Delphi-Jedi (Darth) command-line units edition    }');
    writeln('{','}':75);
  {$IFDEF MSDOS}
    GetDate(Year,Month,Day,DayOfWeek);
    GetTime(Hour,Min,Sec,Sec100);
    writeln('{    Generated Date: ',Year mod 100:2,'-',Zero2(Month),'-',Zero2(Day),'}':47);
    writeln('{    Generated Time: ',Zero2(Hour),':',Zero2(Min),':',Zero2(Sec),'}':47);
  {$ELSE}
    writeln('{    Generated Date: ',DateToStr(Date):10,'}':45);
    writeln('{    Generated Time: ',TimeToStr(Time):8,'}':47);
  {$ENDIF}
    writeln('{','}':75);
    writeln('{**************************************************************************}');
    writeln;
  {!ACM -- More File processing }
    System.Assign(def,Dir+DLL+'.~$$');
    System.rewrite(def);
    System.Assign(tmp,Dir+DLL+'.$$$');
    System.rewrite(tmp);
  {!ACM -- Code writing }
    writeln('interface');
    writeln('uses');
    writeln('{$IFDEF WIN32}');
    writeln('  Windows;');
    writeln('{$ELSE}');
    writeln('  Wintypes, WinProcs;');
    writeln('{$ENDIF}');
    writeln;

  end;  { WriteTempFile }

  Procedure PreProcessHeader;   { Nesting Level One }

    Procedure DoInitialProcessing;   { Nesting Level Two; called third }
    begin
      while (IOResult = 0) and not eof(header) do
      begin
        repeat
          readln(header,Str);
          ChangeTabs2Spaces(Str);
          if Str = _START then Start := True
          else
            if Str = _STOP then Start := False;
          if not Start then
          begin
            if Str <> _STOP then
              writeln(Str) { don't convert }
          end
          else { Start }
          begin
            if Str <> _START then
            begin
              ChangeC2Pascal(Str);
              SkipSpaces(Str);
              if (Len = 0) then
               writeln(tmp)
            end
            else Str := '' { skip start }
          end
        until (IOResult <> 0) or eof(header) or (Len > 0);
       {writeln('[',Str,']'); { debug }
      end;
    end; { DoInitialProcessing }

    function CompilerDirectiveFound: boolean;  { Nesting Level Two;
                                                 called fourth }
    begin
      com1 := Pos('#',Str);
      CompilerDirectiveFound := (com1 > 0);
    end; { CompilerDirectiveFound }

    procedure ProcessCompilerDirective;   { Nesting Level Two, called 5th }

      function IncludeFound : boolean;  { Nesting Level Three, called 5th }
      begin
        com := Pos('#include',Str);
        IncludeFound := (com > 0) and (com = com1)
      end; { IncludeFound }

      procedure ProcessInclude;  { Nesting Level Three, called 6th }
      begin
        Delete(Str,1,com+7);
        SkipSpaces(Str);
        writeln(tmp,'{$INCLUDE ',Str,'}')
      end; { ProcessInclude }

      procedure ProcessTypes_Defines_Etc;  { Nesting Level Three, Called 7th }

        function IfDefFound: boolean;  { Nesting Level Four, called 8th }
        begin
          IfDefFound := (Pos('#ifdef',Str) = com) and (com = com1);
        end;  { IfDefFound }

        procedure ProcessDef;  { Nesting Level Four, called ninth }

          function IfPoundIfFound: boolean;  { Nesting Level Five, called 10th }
          begin
            com := Pos('#if',Str);
            IfPoundIfFound := (com > 0) and (com = com1);
          end; { ProcessDef }

          procedure ProcessPoundIf;  { Nesting Level Five, called 11th }
          begin
            Delete(Str,1,com+5);
            SkipSpaces(Str);
            writeln(tmp,'{$IFDEF ',Str,'}')
          end;  { ProcessPoundIf }

          function IfNDefFound: boolean;  { Nesting Level Five, called 12th }
          begin
            IfNDefFound := (Pos('#ifndef',Str) = com) and (com = com1);
          end;  { IfNDefFound }

          procedure ProcessIfNDef;  { Nesting Level Five, called 13th }
          begin
            Delete(Str,1,com+6);
            SkipSpaces(Str);
            writeln(tmp,'{$IFNDEF ',Str,'}')
          end;

          function IfDefinedFound: boolean;  { Nesting Level Five, called 14th }
          begin
            IfDefinedFound := (Pos('#if defined',Str) = com) and (com = com1);
          end; { ProcessIfNDef }

          procedure ProcessIfDefined;  { Nesting Level Five, called 15th }
          begin
            Delete(Str,1,com+10);
            SkipSpaces(Str);
            if (Str[1] = '(') then
            begin
              Delete(Str,1,1);
              SkipSpaces(Str);
              if (Pos(')',Str) <> 0) then Delete(Str,Pos(')',Str),1)
            end;
            writeln(tmp,'{$IFDEF ',Str,'}')
          end; { ProcessIfDefined }

          function IfNotDefinedFound: boolean;  { Nesting Level Five,
                                                  called 16th }
          begin
            IfNotDefinedFound := (Pos('#if !defined',Str) = com) and
              (com = com1);
          end; { IfNotDefinedFound }

          procedure ProcessIfNotDefined;  { Nesting Level Five,
                                            called 17th }
          begin
            Delete(Str,1,com+11);
            SkipSpaces(Str);
            if (Str[1] = '(') then
            begin
              Delete(Str,1,1);
              SkipSpaces(Str);
              if (Pos(')',Str) <> 0) then Delete(Str,Pos(')',Str),1)
            end;
            writeln(tmp,'{$IFNDEF ',Str,'}')
          end;  { ProcessIfNotDefined }

          procedure ProcessIfDef;  { Nesting Level Five }
          begin
            Delete(Str,1,com+2);
            SkipSpaces(Str);
            writeln(tmp,'{$IFDEF ',Str,'}')
          end; { ProcessIfDef }

        begin { ProcessDef }    { Nesting Level Four, called ninth }
          if IfPoundIfFound then ProcessPoundIf
          else
            if IfNDefFound then ProcessIfNDef
            else
              if IfDefinedFound then
                ProcessIfDefined
              else
                if IfNotDefinedFound then
                  ProcessIfNotDefined
                else
                  ProcessIfDef;
        end; { ProcessDef }

      procedure ProcessOtherDirective;    { Nesting Level Three, called 18th }

        procedure SetInitialComPosition;   { Nesting Level Four, called 18th }
        begin
          com := Pos('#else',Str);
          if (com = 0) then com := Pos('#elif',Str);
        end;

        function PoundElseIfFound: boolean; { Nesting Level Four,  called 19th }
        begin
          PoundElseIfFound := (com > 0) and (com = com1);
        end;

        procedure ProcessPoundElseIf; { Nesting Level Four, called 20th }

          function ExclamationDefinedFound: boolean; { Nesting Level Five,
                                                       called 21st  }
          begin
            ExclamationDefinedFound := (Pos('!defined(',Str) > 0) and
              (com = com1);
          end;

          procedure ProcessExclamationDefined;{ Nesting Level Five, called 22nd }
          begin
            Delete(Str,Pos('!defined(',Str),9);
            Delete(Str,Pos(')',Str),1);
            SkipSpaces(Str)
          end;

          procedure CheckForSpecialDefined;{ Nesting Level Five, called 23rd }
          begin
            if (Pos('defined(',Str) > 0) and (com = com1) then
            begin
              Delete(Str,Pos('defined(',Str),8);
              Delete(Str,Pos(')',Str),1);
              SkipSpaces(Str)
            end
          end; { CheckForSpecialDefined }

        begin { ProcessPoundElseIf } { Nesting Level Four, called 20th }
          Delete(Str,1,com+4);
          SkipSpaces(Str);
          if ExclamationDefinedFound then ProcessExclamationDefined
          else CheckForSpecialDefined;
          if (Len > 0) then writeln(tmp,'{$ELSE ',Str,'}')
                       else writeln(tmp,'{$ELSE}')
        end; { ProcessPoundElseIf }

        procedure ProcessOtherDefine;  { Nesting Level Four, called 24th }

          function PoundEndifFound: boolean; { Nesting Level Five, called 25th }
          begin
            com := Pos('#endif',Str);
            PoundEndifFound := (com > 0) and (com = com1);
          end; { PoundEndifFound }

          procedure ProcessPoundEndif; { Nesting Level Five, called 26th }
          begin
            Delete(Str,1,com+5);
            SkipSpaces(Str);
            if (Len > 0) then writeln(tmp,'{$ENDIF ',Str,'}')
                         else writeln(tmp,'{$ENDIF}')
          end; { ProcessPoundEndif }

          function PoundDefineFound: boolean; { Nesting Level Five, called 27th }
          begin
            com := Pos('#define',Str);
            PoundDefineFound := (com > 0) and (com = com1);
          end; { PoundDefineFound }

          procedure ProcessPoundDefine; { Nesting Level Five, called 28th }

            function DefineFound: boolean;  { Nesting Level Six, called 29th }
            begin
              Delete(Str,1,com+6);
              SkipSpaces(Str);
              com := Pos(' ',Str);
              DefineFound := (com = 0);
            end;

            procedure ProcessConst;  { Nesting Level Six, called 30th }
            begin
              repeat
                Delete(Str,com,1)
              until (Str[com] <> ' ');
              Insert('=',Str,com);
              if (Str[com+1] = '0') and (UpCase(Str[com+2]) = 'X') then
              begin { add '$' to hex numbers }
                Delete(Str,com+1,1) { ' ' };
                Str[com+1] := '$'
              end;
              com := Pos(' ',Str);
              if (com = 0) then com := len+1;
              Insert(';',Str,com);

              i := Pos('=',Str);
              while (i <= com) do
              begin
                Inc(i);
                if (Str[i] in ['L','l','U','u','F','f']) and
                   (Str[i-1] in ['0'..'9','A'..'F']) and
                    not (Str[i+1] in IdentSet) then
                begin
                  Delete(Str,i,1);
                  i := Len
                end
              end;

              com := Pos('//',Str);
              if (com > 0) then
              begin
                i := Pos('/*',Str);
                if (i > 0) and (i < com) then com := i;
                Insert('{',Str,com);
                Insert('}',Str,len+1)
              end
              else
              begin
                com := Pos('/*',Str);
                if (com > 0) then
                begin
                  Insert('{',Str,com);
                  Insert('}',Str,len+1)
                end
              end;
              com := Pos('=',Str);
              Insert(' ',Str,com+1);
              Insert(' ',Str,com);
              writeln(tmp,'{} const ',Str);
            end; { ProcessConst }

          begin { ProcessPoundDefine, called 28th }
            if DefineFound then
              writeln(tmp,'{$DEFINE ',Str,'}')
            else ProcessConst;
          end; { ProcessPoundDefine }

        begin { ProcessOtherDefine called 24th}
          if PoundEndifFound then ProcessPoundEndif
          else
            if PoundDefineFound then ProcessPoundDefine
            else writeln(tmp,'{ ',Str,' }')
        end; { ProcessOtherDefine }

      begin  { ProcessOtherDirective called 18th}
        SetInitialComPosition;
        if PoundElseIfFound then ProcessPoundElseIf  {called 20th}
        else ProcessOtherDefine; { called 24th }
      end; { ProcessOtherDirective }

  begin  { ProcessCompilerDirective called 5th}
        if IfDefFound then ProcessDef  { called 9th }
        else ProcessOtherDirective; { called 18th }
  end;

    begin   { ProcessCompilerDirective }
      if IncludeFound then ProcessInclude
        else
          ProcessTypes_Defines_Etc;
    end; { ProcessCompilerDirective }

    procedure ProcessOtherDirective;

      procedure ProcessCommentStart;
      var
        l : integer;
      begin
        if (com <> 1) then com := Pos('//',Str);
        if (com = 1) then
        begin
          writeln(tmp,'{/',Str,' }':76-Len);
          Len := 0 { prevent comment from being written again... }
        end
        else { no comment }
        begin
          if (com > 0) then Len := com-1; { skip everything after '//' }
          if (Len > 0) then
          repeat
            if not comment then
            begin
              com := Pos('/*',Str);
              if (com = 1) then { start comment line }
              begin
                Str[2] := '/';
                writeln(tmp,'{+',Str,' }':76-Len);
                comment := Pos('*/',Str) = 0; { no reverse?? }
                Len := 0; { prevent comment from being written again... }
                com := 0 { hack }
              end
              else
              begin
                if (com > 0) then
                begin { write everything before a comment }
                  for l := 1 to com-1 do
                  begin
                    write(tmp,Str[l]);
                    if (Str[l] in [';','{','}']) then writeln(tmp)
                  end;
                  Str := Copy(Str,com+2,len-com-1); { !!0.6!! }
                  comment := True
                end
              end
            end
            else { in comment }
            begin
              com := Pos('*/',Str);
              if (Len > 1) and ((com+1) = Len) then { end comment line }
              begin
                Dec(Len,2);
                writeln(tmp,'{=',Str,' }':76-Len);
                comment := False;
                Len := 0; { prevent comment from being written again... }
                com := 0 { hack }
              end
              else { just another comment line... }
              begin
                if (com > 0) then
                begin { skip everything in a comment }
                  Str := Copy(Str,com,len-com-1);
                  comment := False
                end
              end
            end
          until (com = 0) or (len = 0)
        end;
      end; { ProcessCommentStart }

      procedure ProcessNonComment;
      var
        l : integer;
      begin  { ProcessNonComment }
        InArray := False;
        LeadingSpace := True; { skip leading spaces on every line }
        for l:=1 to Len do
        begin
          if Str[l] = '[' then InArray := True;
          if Str[l] = ']' then InArray := False;
          if InArray and (Str[l] = ' ') then
            { skip empty space v3.09 }
          else
            if (Str[l] <> ' ') or not LeadingSpace then write(tmp,Str[l]);
          LeadingSpace := LeadingSpace AND (Str[l] = ' ');
          if (Str[l] in [';','{','}']) then
          begin
            writeln(tmp);
            LeadingSpace := True
          end
        end;
        if (Len > 0) then write(tmp,' ')
      end; { ProcessNonComment }

    begin { ProcessOtherDirective }
      com := com1;
      ProcessCommentStart;
      if not comment then ProcessNonComment
      else if (Len > 0) then writeln(tmp,'{-',Str,' }':76-Len);
    end;  { ProcessOtherDirective }

  begin { PreProcessHeader }
    DoInitialProcessing;

      if CompilerDirectiveFound then
       ProcessCompilerDirective
      else ProcessOtherDirective;
  end;

  procedure ProcessTmpFile;

    procedure DoPreProcessingOnTmpFile;
    begin
      System.close(header);
      writeln;
      writeln('{=> ',Dir,DLL,'.H <=}');
      writeln;
      { interface }
    {$IFDEF MSDOS}
      System.Close(tmp);
      System.Assign(tmp,Dir+DLL+'.$$$');
    {$ENDIF}
      System.Reset(tmp);
    end;

    procedure ProcessSpacesInTmpFile;
    begin
      repeat
        readln(tmp,Str);
        SkipSpaces(Str);
        if (Len = 0) then writeln
      until (IOResult <> 0) or eof(tmp) or (Len > 0);
    end;

    function CurleyBracketAtStart: boolean;
    begin
      CurleyBracketAtStart := (Str[1] = '{');
    end;

    procedure ProcessCurleyBracket;
    begin
      if (Str[2] = '}') then
        begin
          Delete(Str,1,3);
          if (Pos('const ',Str) = 1) and (Pos(';',Str) > 0) then
          begin
            Delete(Str,Pos(';',Str),1);
            i := Pos('{',Str);
            if (i = 0) then Str := Str + ';'
                       else Insert(';',Str,i-1);
            i := Pos(';',Str)-1;
            while (Str[i] = ' ') do
            begin
              Delete(Str,i,1);
              Dec(i)
            end
          end;
          i := Pos('"',Str);
          while (i > 0) do
          begin
            Str[i] := '''';
            i := Pos('"',Str)
          end
        end;
        writeln(Str)
    end;

    function NotTypeDefFound: boolean;
    begin
      com := Pos('typedef ',Str);
      NotTypeDefFound := (com = 0);
    end;

    procedure ProcessNonCurleyBracketedCode;
    var
      i, j : integer;
      procedure FindUnionOrEnum;
      begin
        com := Pos('struct ',Str);
        if (Pos('(',Str) in [1..com]) then com := 0 { function API };
        if (com = 0) then com := Pos('union ', Str);
        if (com = 0) then com := Pos('enum ', Str);
      end;

      function StructOrUnionFound: boolean;
      begin
        StructOrUnionFound := (Pos('struct ',Str) > 0) or
          (Pos('union ',Str) > 0);
      end;

      procedure ProcessStructOrUnion;
        procedure DeleteKeyWords;
        begin
          j := 0;
          Union := Pos('union',Str) > 0;
          if (Pos('typedef ',Str) > 0) then Delete(Str,Pos('typedef ',Str),8);
          if Union then Delete(Str,Pos('union ',Str),6)
                   else Delete(Str,Pos('struct ',Str),7);
          SkipSpaces(Str);
        end; { DeleteKeyWords }

        procedure WritePascalType;

          function NoCurleyBracketFound: boolean;
          begin
            NoCurleyBracketFound := (Pos('{',Str) = 0);
          end; { NoCurleyBracketFound }

          function SimpleTypeDefFound: boolean;
          begin
            SimpleTypeDefFound := (Pos(' ',Str) > 0) and (Pos(';',Str) > 0);
          end; { SimpleTypeDefFound }

          procedure WriteRecordWithCase;
          begin
            writeln('type ',Str,' = record');
            if Union then writeln(' ':4{:10+Len},'case Word of');
            Commentaar := Str;
            Len := 0;
            while (Len = 0) and not eof(tmp) do readln(tmp,Str)
          end; { WriteRecordWithCase }

          procedure WriteRecordWithoutCase;
          begin
            Commentaar := Copy(Str,1,Pos('{',Str)-1);
            SkipSpaces(Commentaar);
            writeln('type ',Commentaar,' = record');
            if Union then
              writeln(' ':4{:10+Length(Commentaar)},'case Word of');
            Delete(Str,1,Pos('{',Str)-1)
          end; { WriteRecordWithoutCase }

          procedure ProcessEmptyType;
          begin
            Inc(Emptytype);
            System.Str(Emptytype:1,Commentaar);
            Commentaar := '_'+Commentaar;
            LastEmptyType := Commentaar;
            writeln('type ',Commentaar,' = record');
            if Union then
              writeln(' ':4{:10+Length(Commentaar)},'case Word of');
          end; { ProcessEmptyType }

          procedure ProcessCurleyBracket;
          begin
            Inc(nested);
            if (Pos('{',Str) > 1) then  WriteRecordWithoutCase
            else { pos = 1... } ProcessEmptyType;
          end; { ProcessCurleyBracket }

          function CurleyBracketAtStart: boolean;
          begin
            CurleyBracketAtStart := (Str[1] = '{');
          end; { CurleyBracketAtStart }

          procedure ProcessAnotherCurleyBracket;
          begin
            Delete(Str,1,1);
            repeat
              SkipSpaces(Str);
              { process }
              { TODO: add union support here }
              if (Len > 0) then
              begin
                Inc(j);
                if Union then
                  write(j:6{:12+Length(Commentaar)},': (')
                else write(' ':4{:10+Length(Commentaar)});
                i := 0;
                while (i < Len) and (Str[i] <> ',') do Inc(i);
              { i := Len; }
                while (i > 0) and not (Str[i] in [' ','*']) do Dec(i);
                Inc(i);
                if (Str[i] <> '{') then { no comment }
                begin
                  Intype := False;
                  repeat
                    if (Str[i] = '[') then
                    begin
                      Intype := True;
                      write(': Array[0..')
                    end
                    else
                      if (Str[i] = ']') then write('-1] of')
                                        else write(Str[i]);
                    Inc(i)
                  until (i >= Len) or (Str[i] = ';');
                  if not Intype then write(':');
                  write(' ');
                  i := 0;
                  while (i < Len) and (Str[i] <> ',') do Inc(i);
                  Len := i;
                  while (Len > 0) and not (Str[Len] in [' ','*']) do Dec(Len);
                  SkipSpaces(Str);
                  Upper(Str);
                  SkipVoid(Str);
                  FindType(Str,False);
                  if Union then write(';)');
                  writeln(';')
                end
              end;

              readln(tmp,Str);
              SkipSpaces(Str);

              if (Str[1] = '{') then
              begin
                if (Str[2] = '}') then
                begin
                  Delete(Str,1,3);
                  if (Pos('const ',Str) = 1) and (Pos(';',Str) > 0) then
                  begin
                    Delete(Str,Pos(';',Str),1);
                    i := Pos('{',Str);
                    if (i = 0) then Str := Str + ';'
                               else Insert(';',Str,i-1);
                    i := Pos(';',Str)-1;
                    while (Str[i] = ' ') do
                    begin
                      Delete(Str,i,1);
                      Dec(i)
                    end
                  end
                end;
                writeln(Str);
                Len := 0
              end;
              SkipSpaces(Str);
              if Str = '}' then { fix 3.10 }
              begin
                readln(tmp,Str);
                Str := '}' + Str
              end;
              if Pos('}',Str) > 0 then Dec(nested)
            until eof(tmp) or
                ((Pos('}',Str) > 0) and
                ((Pos(';',Str) > Pos('}',Str)) or (nested <= 1)));
          end;  { ProcessAnotherCurleyBracket }

          procedure ProcessLeadingUnderline;
          begin
            if Commentaar = LastEmptyType then
            begin
              Commentaar := '';{ clear }
              Delete(Str,1,Pos('}',Str));
              if (Len = 0) and not eof(tmp) then readln(tmp,Str); { HACK v3.05 }
              SkipSpaces(Str);
              while (Len > 0) and (Str[1] in IdentSet) do
              begin
                Commentaar := Commentaar + Str[1];
                write(Str[1]);
                Delete(Str,1,1)
              end
            end
            else write(Commentaar);
            writeln('};');
            { pointer types }
            while Len > 0 do
            begin
              i := 0;
              while (Len > 0) and not (Str[1] in IdentSet) do
              begin
                if Str[1] = '*' then Inc(i);
                if Str[1] = ';' then Len := 0; { end of typedef }
                Delete(Str,1,1)
              end;
              if Len > 0 then
              begin
              { writeln('type '); }
                write(' ':2);
                while (Len > 0) and (Str[1] in IdentSet) do
                begin
                  write(Str[1]);
                  Delete(Str,1,1)
                end;
                write(' = ');
                while i > 0 do
                begin
                  write('^');
                  Dec(i)
                end;
                writeln(Commentaar,';')
              end
            end
          end; { ProcessLeadingUnderline }

        begin { WritePascalType }
        { writeln; }
          if NoCurleyBracketFound then
          begin
            if SimpleTypeDefFound then { simple typedef }
              writeln('type ',Copy(Str,Pos(' ',Str)+1,Len),
                        ' = ',Copy(Str,1,Pos(' ',Str)-1),';')
            else  WriteRecordWithCase;
          end
          else ProcessAnotherCurleyBracket;
          while (not eof(tmp)) and (Len = 0) or (Pos('{',Str) = 0) do
            readln(tmp,Str);
          Delete(Str,1,Pos('{',Str)-1);

          if CurleyBracketAtStart then ProcessAnotherCurleyBracket;
          nested := 0;
        { else bad struct }
          write(' ':2{:8+Length(Commentaar)},'end {');
          if Commentaar[1] <> '_' then writeln(Commentaar,'};') {3.16}
          else  ProcessLeadingUnderline;
        end; { WritePascalType }


      begin { ProcessStructOrUnion }
        if (Len = 0) then
          while (Len = 0) and not eof(tmp) do readln(tmp,Str);
        if (Len > 0) then WritePascalType;
      end; { ProcessStructOrUnion }

      function EnumFound: boolean;
      begin
        EnumFound := (Pos('enum ',Str) > 0);
      end; { EnumFound }

      procedure ProcessEnum;
      begin
        Delete(Str,1,Pos('enum ',Str)+4);
        SkipSpaces(Str);
        write('type ');
        i := 1;
        if Str[i] = '{' then
        begin
          Inc(Emptytype);
          System.Str(Emptytype:1,Commentaar);
          write('_',Commentaar,' ');
          j := 4 {10 + Length(Commentaar)}
        end
        else
        begin
          repeat
            write(Str[i]);
            Inc(i)
          until (i > Len) or (Str[i] = '{');
          j := 4 {7 + i}
        end;
        write('= (');
        Delete(Str,1,i);
        SkipSpaces(Str);
        Commentaar := ' '; { 3.06 }
        repeat
          while (Len > 0) and (Str[1] <> '}') do
          begin { process }
            write(Commentaar);
            if Length(Commentaar) > 0 then
            begin
              writeln;
              write(' ':j)
            end;
            Commentaar := '';
            i := 1;
            repeat
              write(Str[i]);
              Inc(i);
              if (Str[i] = '=') then
              begin
                write('{');
                Commentaar := '}'
              end;
            until (i > Len) or (Str[i] = ',') or (Str[i] = '}');
            write(Commentaar);
            Commentaar := ', ';
            if (Str[i] = '}') then Dec(i);
            Delete(Str,1,i);
            SkipSpaces(Str)
          end;
          if (Str[1] <> '}') then
          begin
            readln(tmp,Str);
            SkipSpaces(Str)
          end
        until eof(tmp) or (Str[1] = '}');
        write(' )');
        Delete(Str,1,1);
        if Str[1] = ';' then Delete(Str,1,1);
        if Len > 1 then write('{',Str,'}');
        writeln(';')
      end; { ProcessEnum }

      procedure ProcessRegularTypedef;
      begin
        if (Pos(';',Str) > 0) then { one-line typedef }
          begin
            i := Pred(Pos(';',Str));
            while (i > 0) and (Str[i] in IdentSet) do Dec(i);
            write('type ');
            repeat
              Inc(i);
              if (Str[i] <> ';') then write(Str[i]);
            until Str[i] = ';';
            write(' = ');
            Commentaar := Copy(Str,i+1,Len);
            SkipSpaces(Commentaar);
            Dec(i);
            while (i > 0) and (Str[i] in IdentSet) do Dec(i);
            Len := i;
            Delete(Str,1,Pos('typedef ',Str)+7);
            SkipSpaces(Str);
            Upper(Str);
            SkipVoid(Str);
            FindType(Str,False);
            write(';');
            if (Length(Commentaar) > 0) then writeln('{ ',Commentaar,' }')
                                        else writeln
          end
          else { miscelaneous }
          begin
            writeln('{{{ ',Str,' }')
          end;
      end; { ProcessRegularTypedef }

      function OpenParensFound: boolean;
      begin  
        com := Pos('(',Str);
        OpenParensFound := (com > 0);
      end;  { OpenParensFound }

      procedure ProcessOpenParens;

        procedure ScanForParens;
        var
          j : integer;
        begin
          Line[1] := Copy(Str,1,com-1);
          i := 2;
          Line[i] := Copy(Str,com+1,Len-com);
          repeat
            com := Pos(',',Line[i]);
            if (com = 0) or (Pos('}',Line[i]) in [1..com]) then
              com := Pos('}',Line[i]);
            while (com > 0) and (i < MaxLine) do { parse params }
            begin
              Line[i+1] := Copy(Line[i],com+1,Len-com);
              if Line[i,com] = '}' then Line[i,0] :=AnsiChar( Chr(com)) {-}
                                   else Line[i,0] :=AnsiChar( Chr(com-1));
              Inc(i);
              com := Pos(',',Line[i]);
              if (com = 0) or (Pos('}',Line[i]) in [1..com]) then
                com := Pos('}',Line[i])
            end;
            SkipSpaces(Line[i]);
            com := Pos(');',Line[i]); { skip ');' }
            for j:=1 to i do
            begin { patch 3.09 }
              if Pos(',',Line[j]) > 0 then Delete(Line[j],Pos(',',Line[j]),1);
              Line[j,Length(Line[j])+1] := '@'; { hackerty hack }
              SkipSpaces(Line[j]);
            end;
            if com = 0 then com := Pos(')',Line[i]); { GPF 0.99b }
            if (com > 0) then Line[i,0] := AnsiChar(chr(com-1))
            else
            begin
              if (Length(Line[i]) > 0) then Inc(i);
              readln(tmp,Str); { next line... }
              SkipSpaces(Str);
              Line[i] := Str;
              com := Pos(');',Line[i]);
              if com = 0 then com := Pos(')',Line[i]); { GPF 0.99b }
              if (com > 1) then com := 0 { continue scanning }
              else
                if (com = 1) then Dec(i)
            end;
            SkipSpaces(Line[i]); { 3.09 }
          until (com <> 0) or (Len < 2) or (i >= MaxLine) or
                 eof(tmp) or (IOResult <> 0);
        end;  { ScanForParens }

        procedure ProcessComentaar;
        var
          j : integer;

          procedure ProcessExplicit;
          begin
            write('var ');
            trailing := 4;
            { get last word }
            k := Length(Line[1]);
            while (k > 1) and not (Line[1,k] in [' ','*']) do Dec(k);
            { default = int }
            if (k = 1) and not (Line[1,1] in [' ','*']) then { int }
            begin
              { skip, for now }
            end
            else
              Inc(k);
            Name := '';
            repeat
              Name := Name + UpCase(Line[1,k]);
              write(Line[1,k]);
              write(def,Line[1,k]); { explicit }
              Inc(trailing);
              Inc(k)
            until k > Length(Line[1]);
            Dec(k);
            while (k > 1) and not (Line[1,k] in [' ','*']) do Dec(k);
            writeln(def); { explicit }
            { default = int }
            if (k = 1) and not (Line[1,1] in [' ','*']) then { int }
              Line[1] := 'INT'
            else
              Line[1,0] :=AnsiChar( Chr(k));
            SkipSpaces(Line[1]);
            { got last word }
            Upper(Line[1]);
            if (Pos('VOID ',Line[1]) = 1) or (Pos('void ',Line[1]) = 1)  then
            begin
              Inc(trailing,11-2); { 3.06 }
              write(': procedure')
            end
            else
            begin
              Inc(trailing,10-2);
              write(': function')
            end
          end; { ProcessExplicit }

          procedure ProcessImplicit;
          begin { ProcessImplicit }
            if (Pos('void ',Line[1]) = 1) then
              begin
                trailing := 10;
                writeln;
                write('procedure ');
                write(def,'procedure ')
              end
              else
              begin
                trailing := 9;
                writeln;
                write('function ');
                write(def,'function ')
              end;
              { get last word }
              k := Length(Line[1]);
              while (k > 1) and not (Line[1,k] in [' ','*']) do Dec(k);
              { default = int }
              if (k = 1) and not (Line[1,1] in [' ','*']) then { int }
              begin
                { skip, for now }
              end
              else
                Inc(k);
              Name := '';
              repeat
                Name := Name + UpCase(Line[1,k]);
                write(Line[1,k]);
                write(def,Line[1,k]);
                Inc(trailing);
                Inc(k)
              until k > Length(Line[1]);
              Dec(k);
              while (k > 1) and not (Line[1,k] in [' ','*']) do Dec(k);
              writeln(def);
              { default = int }
              if (k = 1) and not (Line[1,1] in [' ','*']) then { int }
                Line[1] := 'int'
              else
                Line[1,0] :=AnsiChar( Chr(k));
              SkipSpaces(Line[1]);
              { got last word }
              Upper(Line[1])
          end; { ProcessImplicit }

        begin { ProcessComentaar }
          Commentaar := '';
          for j:=1 to i do
          begin
            if Length(Commentaar) > 0 then
            begin
              Dec(Commentaar[0]);
              SkipSpaces(Commentaar);
              write(Commentaar,' }')
            end;
            SkipSpaces(Line[j]);
            if (Pos('{',Line[j]) > 0) and (Pos('}',Line[j]) > 0) then
            begin
              Commentaar := Copy(Line[j],Pos('{',Line[j]),Length(Line[j]));
              Line[j,0] := AnsiChar(Chr(Pos('{',Line[j])-1));
              SkipSpaces(Line[j])
            end
            else Commentaar := '';

            if (j = 1) then
            begin
            { writeln(Line[j]) { proc name & type
              writeln; }
              if Explicit then ProcessExplicit
              else ProcessImplicit{ implicit }
            end
            else
            if (j = 2) and (i = 2) and
              ((Line[j] = 'void') or (Line[j] = 'VOID') or (Line[j,1] = ')')) then
            begin
              { no arguments }
            end
            else { argument list }
            begin
              if (j = 2) then
              begin
                inc(trailing);
                write('(')
              end
              else
              begin
                writeln;
                write(' ':trailing)
              end;
              FindConst(Line[j]);
              { get last word }
              k := Length(Line[j]);
              if (k >= 1) and (Line[j,1] <> '{') then
              begin
                if Line[j,k] = '*' then Dec(k); { 3.09 fix }
                while (k >= 1) and not (Line[j,k] in [' ','*']) do Dec(k);
                if (k <= 1) then { Marco Cantu }
                begin
                  System.Str(j-1:1,Number); { start with 1 }
                  write('_',Number)
                end
                else
                begin
                  Inc(k);
                  repeat
                    write(Line[j,k]);
                    Inc(k)
                  until k > Length(Line[j]);
                  Dec(k);
                  while (k > 1) and not (Line[j,k] in [' ','*']) do Dec(k);
                  Line[j,0] := AnsiChar(Chr(k));
                  SkipSpaces(Line[j]);
                  { got last word }
                end;
                write(': ');
                Upper(Line[j]);
                { change ' *' into '* '
                repeat
                  com := Pos(' *',Line[j]);
                  if (com > 0) then
                  begin
                    Line[j,com] := '*';
                    Line[j,com+1] := ' '
                  end
                until com = 0;
                { changed ' *' into '* ' }
                SkipSpaces(Line[j]);
                SkipVoid(Line[j]);
                FindType(Line[j],False);
                if (j < i) then write('; ')
                           else write(')')
              end
              else
              begin
                writeln(')') { BUG I don't know why... }
              end
            end
          end;
        end; { ProcessComentaar }

        procedure ProcessCDECL;
        var
          i : integer;
        begin
          cdecl := True;
          for i:=1 to MaxVoid do
          begin
            repeat
              k:=Pos(Void[i],Line[1]);
              if (k > 0) and
                ((k = 1) or not (Line[1,k-1] in IdentSet)) and
                ((Length(Line[1]) <= (Length(Void[i])+k)) or
                 (Line[1,k+Length(Void[i])] in [' ','*',';',')'])) then
              begin
                cdecl := (i >= PasVoid) and cdecl;
                Delete(Line[1],k,Length(Void[i]));
                if (Line[1,k-1] = '_') then Delete(Line[1],k-1,1);
              { Line[1,0] := Chr(k-1); }
                SkipSpaces(Line[1]);
                while (Line[1,Length(Line[1])] = '*') and
                      (Line[1,Length(Line[1])-1] = ' ') do
                  Delete(Line[1],Length(Line[1])-1,1)
              end
              else k := 0
            until k = 0
          end;

          if (Pos('VOID',Line[1]) = 0) and (Pos('void',Line[1]) = 0) then
          begin { function type? }
            write(': ');
            FindType(Line[1],True)
          end
          else { 3.15 }
          begin
            Delete(Line[1],1,4);
            SkipSpaces(Line[1]);
            if not (Line[1,1] in IdentSet) then
            begin
              write(': ');
              Line[1] := 'VOID' + Line[1];
              FindType(Line[1],True)
            end
          end;
          if cdecl then write(' cdecl ') { remove ';' before cdecl };
          write(' {$IFDEF WIN32} stdcall {$ENDIF}');
          writeln('; '{; far;'})
        end; { ProcessCDECL }

      begin { ProcessOpenParens }
        ScanForParens;
        ProcessComentaar;
        ProcessCDECL;
      end;  { ProcessOpenParens }

    begin { ProcessNonCurleyBracketedCode }
      if NotTypeDefFound then
        if (com > 0) then { typedef/struct }
        begin
          if StructOrUnionFound then ProcessStructOrUnion
          else
          begin
            if EnumFound then ProcessEnum
            else ProcessRegularTypedef; { regular typedef }
          end
        end
        else
          If OpenParensFound then ProcessOpenParens;
    end;  { ProcessNonCurleyBracketedCode }

  begin  { ProcessTmpFile }
    DoPreProcessingOnTmpFile;
    while (IOResult = 0) and not eof(tmp) do
    begin
      ProcessSpacesInTmpFile;
      if CurleyBracketAtStart then
       ProcessCurleyBracket
      else ProcessNonCurleyBracketedCode;
      {end}
    end;
  end;  { ProcessTempFile }

  procedure ProcessExplicit;
    procedure WriteExplicitInfo;
    begin  { WriteExplicitInfo }
      writeln;
      writeln('var');
      writeln('  DLLLoaded: Boolean { is DLL (dynamically) loaded already? }');
      writeln('    {$IFDEF WIN32} = False; {$ENDIF}');
      writeln;
      writeln('implementation');
      writeln;
      writeln('var');
      writeln('  SaveExit: pointer;');
      writeln('  DLLHandle: THandle;');
      writeln('{$IFNDEF MSDOS}');
      writeln('  ErrorMode: Integer;');
      writeln('{$ENDIF}');
      writeln;
      writeln('  procedure NewExit; far;');
      writeln('  begin');
      writeln('    ExitProc := SaveExit;');
      writeln('    FreeLibrary(DLLHandle)');
      writeln('  end {NewExit};');
      writeln;
      writeln('procedure LoadDLL;');
      writeln('begin');
      writeln('  if DLLLoaded then Exit;');
      writeln('{$IFNDEF MSDOS}');
      writeln('  ErrorMode := SetErrorMode($8000{SEM_NoOpenFileErrorBox});');
      writeln('{$ENDIF}');
      writeln('  DLLHandle := LoadLibrary(''',DLL,'.DLL'');');
      writeln('  if DLLHandle >= 32 then');
      writeln('  begin');
      writeln('    DLLLoaded := True;');
      writeln('    SaveExit := ExitProc;');
      writeln('    ExitProc := @NewExit;');
    end;  { WriteExplicitInfo }
  begin { ProcessExplicit }
    WriteExplicitInfo;
    reset(def);
    while not eof(def) do
    begin
      readln(def,Str);
      if Len > 0 then
      begin
        write('@':5,Str);
      { Upper(Str); }
        writeln(' := GetProcAddress(DLLHandle,''',Str,''');');
        writeln('  {$IFDEF WIN32}');
        writeln('    Assert(@',Str,' <> nil);');
        writeln('  {$ENDIF}')
      end
    end;
    writeln('  end');
    writeln('  else');
    writeln('  begin');
    writeln('    DLLLoaded := False;');
    writeln('    { Error: ',DLL,'.DLL could not be loaded !! }');
    writeln('  end;');
    writeln('{$IFNDEF MSDOS}');
    writeln('  SetErrorMode(ErrorMode)');
    writeln('{$ENDIF}');
    writeln('end {LoadDLL};');
    writeln;
    writeln('begin');
    writeln('  LoadDLL;')
  end; { ProcessExplicit }

  Procedure ProcessImplicit;
    begin
      writeln;
      writeln('implementation');
      writeln;
      reset(def);
      while not eof(def) do
      begin
        readln(def,Str);
        if Len > 0 then writeln(Str,'; external ''',DLL,'.DLL'';')
      end;
      writeln
    end; { ProcessImplicit }

  Procedure CopyPasFile;

    Procedure SetupFiles;
    begin { SetupFiles }
      writeln('end.');
      if IOResult <> 0 then { skip };
      System.close(tmp);
      System.close(def);
      if IOResult <> 0 then { skip };
      Erase(def);
      Erase(tmp);
      if IOResult <> 0 then { skip };
      System.close(output);
      Assign(output,Dir+DLL+'.PAS');
      rewrite(output);
    { System.close(input); }
      Assign(input,Dir+DLL+'.~PA');
      Reset(input);
    end;  { SetupFiles }

    Procedure WriteLines;
    var
      k : integer;
    begin
      j := 0; { lines read so far }
      Commentaar := '';
      InType := False;
      while not eof do
      begin
        Reset(input);
        for k:=1 to j do readln(Str);
        k := 0;
        while (k = 0) and not eof do
        begin
          readln(Str);
          Inc(j);
          if not Explicit and
            ((Pos('procedure ',Str) = 1) or
             (Pos('function ',Str) = 1)) then InType := False; { 3.24 }
          if (Pos(': P',Str) > 0) and (Pos('const ',Str) = 0) and
             (Pos(': PChar',Str) = 0) and
             (Pos(': Pointer',Str) = 0) and { 3.13 }
              not InType then
          begin
            i := Pos(': P',Str);
            Delete(Str,i+2,1);
            repeat
              Dec(i)
            until (i <= 1) or (Str[i-1] in [' ','(']);
            Insert('var ',Str,i)
          end;
          while Pos('+1-1]',Str) > 1 do Delete(Str,Pos('+1-1]',Str),4);
          if Pos('var ',Str) = 1 then
          begin
            InType := False;
            writeln('var');
            Delete(Str,1,3);
            Str := ' ' + Str
          end
          else
          if Pos('const ',Str) = 1 then
          begin
            InType := True;
            writeln('const');
            Delete(Str,1,5);
            Str := ' ' + Str
          end
          else
          if Pos('type ',Str) = 1 then
          begin
            InType := True;
            i := 0;
            if Pos('type _',Str) = 1 then
            begin
              i := 6;
              repeat
                Inc(i);
              until (i >= Len) or not (Str[i] in ['0'..'9']);
              Dec(i); { go to last valid character... }
              if i > Len then i := Len
            end;
            if (i > 0) and (Str[i] in ['0'..'9']) then
            begin
              if Commentaar <> '' then { replaced }
              begin
                Delete(Str,1,5);
                while (Len > 0) and (Str[1] <> ' ') do Delete(Str,1,1);
                SkipSpaces(Str);
                writeln('type'); { 3.19 }
                Str := '  '+Commentaar+' '+Str;
                Commentaar := ''
              end
              else
              begin
                k := j;
                Commentaar := '';
                while not eof and (Pos('end {',Commentaar) <> 1) do
                begin
                  readln(Commentaar);
                  SkipSpaces(Commentaar)
                end;
                if Pos('end {',Commentaar) = 1 then
                begin
                  Delete(Commentaar,1,5);
                  Delete(Commentaar,Pos('}',Commentaar),255)
                end;
                Dec(j); { 3.21 }
              { reset(input) { patch }
              end
            end
            else
            begin
              writeln('type');
              Delete(Str,1,4);
              SkipSpaces(Str);
              Str := '  '+Str
            end
          end;
          if k = 0 then writeln(Str)
        end
      end;
    end; { WriteLines }

    Procedure CloseFiles;
    begin
      close(input);
      erase(input);
      close(output);
    end; { CloseFiles }

  begin { CopyPasFile }
    SetupFiles;
    WriteLines;
    CloseFiles;
  end; { CopyPasFile }

begin {!ACM HeadConvert main routine}
  if NOT SetupInitialFiles then exit;
  WriteTempFile;
  PreProcessHeader;
  ProcessTmpFile;
  if Explicit then ProcessExplicit
    else ProcessImplicit;
  CopyPasFile;
end {HeadConvert};

end.
